Pascal Super Library/Pascal Super Library (CW International)(1997).bin/DELPHI32/GRIDS/MSTRGRID/MSTRLIST.PAS

Pascal/Delphi Source File | 1996-06-17 | 15KB | 476 lines

unit mstrlist;

(* Version 1.0,  10.6.1996,  Freeware, Albrecht Mengel, [e-mail]

This is a sister of TStringList with some new sorting properties:

property KeyType:(soString,soStringCaseSensitive,soNumeric)
   This is the kind, how the keys (and cells) are compared.
   If you work with soNumeric, all non numbers get the same value 0.
      As these zero values would flip in random order a (case insensitive) string sort
      is performed after. So, first come the negatives, then the strings, and thereafter
      the positives.
property KeyPos:Integer;
property KeyLen:Integer;
   Here you may define, which substring of the cells is used to comparision.
   (Default is KeyPos=1 & KeyLen=MaxInt)
property ScipFirst:Integer;
   Here you can exclude some first entries from sorting.
   (It is used by mStringGrid for excluding fixed rows/cols)

When you set sorting to true then the sorting is done with the new properties.
The default settings result in the same sorting as TStringList does.

TmStrList is a copy of TStringList found in \source\vcl\grids.pas with some additional
entries.
I had a problem with compiling TStringList.Changed and TStringList.Changing:
They call the property FUpdateCount which I could not reach:

procedure TmStrList.Changed;
begin
  if {!(FUpdateCount = 0) and} Assigned(FOnChange) then FOnChange(Self);
end;

procedure TmStrList.Changing;
  ... the same ...

Is there anyone to fix that problem???

Software development:

Programming consumes time, and programmed components save time.
If you like my components feel free to send me some acknowledgment.
I accept post cards of your town, money or cheques (2$ up to 20$).
This is a motivation for me to continue developing for you.

If you have some ideas to improve mStrList, mStrGrid or any other component
send me a message.

The mStrList is copyright (C) 1996, by Albrecht Mengel. You may give copies to
others by copying the original, unmodified zip file. You may use this component
in your own projects free of charge as long as those projects are public domain,
freeware or shareware project.

The author of mStrList (A. Mengel) makes no warranty of any kind,
expressed or implied, including without limitation any warranties of merchantability
and/or fitness for a particular purpose. In no event will the author be liable to you
for any additional damages, including any lost profits, lost savings, or other
incidental or consequential damages arising from the use of, or inability to use,
this software and its accompanying documentation, even if the author has been advised
of the possibility of such damages.

Albrecht Mengel, University of Kiel, Germany
Institute for Statistics & Economics
Olshausenstrasse 40-60,
D-24098 Kiel
Tel. [phone]
Fax. [phone]
Email: [e-mail]
http://www.stat-econ.uni-kiel.de/pers/mengel.htm
*)

{$R-}

interface

uses classes;

type

  TMSortType = (soString,soStringCaseSensitive,soNumeric);
  TmStrList = class(TStrings)
  private
    fKeyType:TMSortType;
    fKeyLen:Integer;
    fKeyPos:Integer;
    fScipFirst:Integer;
    FList: PStringItemList;
    FCount: Integer;
    FCapacity: Integer;
    FSorted: Boolean;
    FDuplicates: TDuplicates;
    FOnChange: TNotifyEvent;
    FOnChanging: TNotifyEvent;
    procedure SetKeyType(value:TMSortType);
    procedure SetKeyLen(value:Integer);
    procedure SetKeyPos(value:Integer);
    procedure ExchangeItems(Index1, Index2: Integer);
    procedure Grow;
    procedure QuickSort(L, R: Integer);
    procedure InsertItem(Index: Integer; const S: string);
    procedure SetCapacity(NewCapacity: Integer);
    procedure SetSorted(Value: Boolean);
    procedure Sort_Alpha;
  protected
    procedure Changed; virtual;
    procedure Changing; virtual;
    function Get(Index: Integer): string; override;
    function GetCount: Integer; override;
    function GetObject(Index: Integer): TObject; override;
    procedure Put(Index: Integer; const S: string); override;
    procedure PutObject(Index: Integer; AObject: TObject); override;
    procedure SetUpdateState(Updating: Boolean); override;
  public
    constructor create;
    destructor Destroy; override;
    function Add(const S: string): Integer; override;
    procedure Clear; override;
    procedure Delete(Index: Integer); override;
    procedure Exchange(Index1, Index2: Integer); override;
    function Find(const S: string; var Index: Integer): Boolean; virtual;
    function IndexOf(const S: string): Integer; override;
    procedure Insert(Index: Integer; const S: string); override;
    procedure Sort; virtual;
    property Duplicates: TDuplicates read FDuplicates write FDuplicates;
    property Sorted: Boolean read FSorted write SetSorted;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
    property KeyType:TMSortType read fKeyType write SetKeyType;
    property KeyLen:Integer read fKeyLen write SetKeyLen;
    property KeyPos:Integer read fKeyPos write SetKeyPos;
    property ScipFirst:Integer read fScipFirst write fScipFirst;
  published
  end;

implementation

uses SysUtils, Consts;

FUNCTION rVAL(CONST von:String):Real;
  {Reads a real value out of the string without an error message.
   Returns 0 if no numeric value}
  VAR bis,err:Integer; nach:Real;
  BEGIN VAL(von,nach,bis);
      IF bis>0 THEN VAL(copy(von,1,bis-1),nach,err);
      rVAL:=nach
  END;{rVAL}

constructor TmStrList.create;
begin fKeyPos:=1;
      fKeyLen:=MaxInt;
end;

procedure TmStrList.SetKeyType(value:TMSortType);
begin if value<>fKeyType then
      begin fKeyType:=value;
            if FSorted and (fCount>1)  then
             begin Changing;
                   QuickSort(fScipFirst,fCount-1);
                   if fKeyType=soNumeric then Sort_Alpha;
                   Changed;
end   end    end;

procedure TmStrList.SetKeyLen(value:Integer);
begin if value<>fKeyLen then
      begin if value<1 then value:=1;
            {showmessage('Keylen: '+inttostr(fKeylen)+' -> '+inttostr(value));}
            fKeyLen:=value;
            if FSorted and (fCount>1)  then
             begin Changing;
                   QuickSort(fScipFirst,fCount-1);
                   if fKeyType=soNumeric then Sort_Alpha;
                   Changed;
end   end    end;

procedure TmStrList.SetKeyPos(value:Integer);
begin if value<>fKeyPos then
      begin if value<1 then value:=1;
            {showmessage('KeyPos: '+inttostr(fKeypos)+' -> '+inttostr(value));}
            fKeyPos:=value;
            if FSorted and (fCount>1) then
             begin Changing;
                   QuickSort(fScipFirst,fCount-1);
                   if fKeyType=soNumeric then Sort_Alpha;
                   Changed;
end   end    end;

procedure TmStrList.QuickSort(L, R: Integer);
var
  I, J: Integer;
  P: string; Pr:Real;
begin
  case fKeyType of
   soString:  repeat I := L; J := R;
                     P := copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen);
                     repeat while AnsiCompareText(copy(FList^[I].FString,fKeyPos,fKeyLen),P)<0 do Inc(I);
                            while AnsiCompareText(copy(FList^[J].FString,fKeyPos,fKeyLen),P)>0 do Dec(J);
                            if I <= J then begin
                               ExchangeItems(I, J);
                               Inc(I);      Dec(J);
                            end;
                     until I > J;
                     if L < J then QuickSort(L, J);
                     L := I;
              until I >= R;
   soStringCaseSensitive:
              repeat I := L; J := R;
                     P := copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen);
                     repeat while copy(FList^[I].FString,fKeyPos,fKeyLen)<P do Inc(I);
                            while copy(FList^[J].FString,fKeyPos,fKeyLen)>P do Dec(J);
                            if I <= J then begin
                               ExchangeItems(I, J);
                               Inc(I);      Dec(J);
                            end;
                     until I > J;
                     if L < J then QuickSort(L, J);
                     L := I;
              until I >= R;
   soNumeric: repeat I := L; J := R;
                     Pr:= Rval(copy(FList^[(L + R) shr 1].FString,fKeyPos,fKeyLen));
                     repeat while Rval(copy(FList^[I].FString,fKeyPos,fKeyLen))<Pr do Inc(I);
                            while Rval(copy(FList^[J].FString,fKeyPos,fKeyLen))>Pr do Dec(J);
                            if I <= J then begin
                               ExchangeItems(I, J);
                               Inc(I);      Dec(J);
                            end;
                     until I > J;
                     if L < J then QuickSort(L, J);
                     L := I;
              until I >= R;
  end
end;

procedure ListError(Ident: Integer);
begin
  raise EListError.CreateRes(Ident);
end;

procedure ListIndexError;
begin
  ListError(SListIndexError);
end;

destructor TmStrList.Destroy;
begin
  FOnChange := nil;
  FOnChanging := nil;
  if FCount <> 0 then Finalize(FList^[0], FCount);
  FCount := 0;
  SetCapacity(0);
end;

function TmStrList.Add(const S: string): Integer;
begin
  if not Sorted then
    Result := FCount
  else
    if Find(S, Result) then
      case Duplicates of
        dupIgnore: Exit;
        dupError: ListError(SDuplicateString);
      end;
  InsertItem(Result, S);
end;

procedure TmStrList.Changed;
begin
  if {!(FUpdateCount = 0) and} Assigned(FOnChange) then FOnChange(Self);
end;

procedure TmStrList.Changing;
begin
  if {!(FUpdateCount = 0) and} Assigned(FOnChanging) then FOnChanging(Self);
end;

procedure TmStrList.Clear;
begin
  if FCount <> 0 then
  begin
    Changing;
    Finalize(FList^[0], FCount);
    FCount := 0;
    SetCapacity(0);
    Changed;
  end;
end;

procedure TmStrList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then ListIndexError;
  Changing;
  Finalize(FList^[Index]);
  Dec(FCount);
  if Index < FCount then
    System.Move(FList^[Index + 1], FList^[Index],
      (FCount - Index) * SizeOf(TStringItem));
  Changed;
end;

procedure TmStrList.Exchange(Index1, Index2: Integer);
begin
  if (Index1 < 0) or (Index1 >= FCount) or
    (Index2 < 0) or (Index2 >= FCount) then ListIndexError;
  Changing;
  ExchangeItems(Index1, Index2);
  Changed;
end;

procedure TmStrList.ExchangeItems(Index1, Index2: Integer);
var
  Temp: Integer;
  Item1, Item2: PStringItem;
begin
  Item1 := @FList^[Index1];
  Item2 := @FList^[Index2];
  Temp := Integer(Item1^.FString);
  Integer(Item1^.FString) := Integer(Item2^.FString);
  Integer(Item2^.FString) := Temp;
  Temp := Integer(Item1^.FObject);
  Integer(Item1^.FObject) := Integer(Item2^.FObject);
  Integer(Item2^.FObject) := Temp;
end;

function TmStrList.Find(const S: string; var Index: Integer): Boolean;
var
  L, H, I, C: Integer;
begin
  Result := False;
  L := 0;
  H := FCount - 1;
  while L <= H do
  begin
    I := (L + H) shr 1;
    C := AnsiCompareText(FList^[I].FString, S);
    if C < 0 then L := I + 1 else
    begin
      H := I - 1;
      if C = 0 then
      begin
        Result := True;
        if Duplicates <> dupAccept then L := I;
      end;
    end;
  end;
  Index := L;
end;

function TmStrList.Get(Index: Integer): string;
begin
  if (Index < 0) or (Index >= FCount) then ListIndexError;
  Result := FList^[Index].FString;
end;

function TmStrList.GetCount: Integer;
begin
  Result := FCount;
end;

function TmStrList.GetObject(Index: Integer): TObject;
begin
  if (Index < 0) or (Index >= FCount) then ListIndexError;
  Result := FList^[Index].FObject;
end;

procedure TmStrList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 8 then Delta := 16 else
    if FCapacity > 4 then Delta := 8 else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

function TmStrList.IndexOf(const S: string): Integer;
begin
  if not Sorted then Result := inherited IndexOf(S) else
    if not Find(S, Result) then Result := -1;
end;

procedure TmStrList.Insert(Index: Integer; const S: string);
begin
  if Sorted then ListError(SSortedListError);
  if (Index < 0) or (Index > FCount) then ListIndexError;
  InsertItem(Index, S);
end;

procedure TmStrList.InsertItem(Index: Integer; const S: string);
begin
  Changing;
  if FCount = FCapacity then Grow;
  if Index < FCount then
    System.Move(FList^[Index], FList^[Index + 1],
      (FCount - Index) * SizeOf(TStringItem));
  with FList^[Index] do
  begin
    Pointer(FString) := nil;
    FObject := nil;
    FString := S;
  end;
  Inc(FCount);
  Changed;
end;

procedure TmStrList.Put(Index: Integer; const S: string);
begin
  if Sorted then ListError(SSortedListError);
  if (Index < 0) or (Index >= FCount) then ListIndexError;
  Changing;
  FList^[Index].FString := S;
  Changed;
end;

procedure TmStrList.PutObject(Index: Integer; AObject: TObject);
begin
  if (Index < 0) or (Index >= FCount) then ListIndexError;
  Changing;
  FList^[Index].FObject := AObject;
  Changed;
end;

procedure TmStrList.SetCapacity(NewCapacity: Integer);
begin
  ReallocMem(FList, NewCapacity * SizeOf(TStringItem));
  FCapacity := NewCapacity;
end;

procedure TmStrList.SetSorted(Value: Boolean);
begin
  if FSorted <> Value then
  begin
    if Value then Sort;
    FSorted := Value;
  end;
end;

procedure TmStrList.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;

procedure TmStrList.Sort;
begin
  if not Sorted and (FCount > 1) then
  begin
    Changing;
    QuickSort(fScipFirst, FCount - 1);
    if fKeyType=soNumeric then Sort_Alpha;
    Changed;
  end;
end;

procedure TmStrList.Sort_Alpha;
var anfang,ende:integer; found:boolean;
begin {soNumeric : die Alpha-EintrΣge nachsortieren}
      anfang:=fScipFirst;
      found:=false;
      while anfang<fCount do
       if rval(copy(FList^[anfang].FString,fKeyPos,fKeyLen))<>0
        then inc(anfang)
        else begin found:=true;
                   break
             end;
      if not found then exit;
      ende:=anfang+1;
      while ende<fCount do
       if rval(copy(FList^[ende].FString,fKeyPos,fKeyLen))=0
        then inc(ende)
        else break;
      if anfang<ende-1 then
      begin fKeyType:=soString;
            QuickSort(anfang,ende-1);
            fKeyType:=soNumeric
end   end;

end.